home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / views / number-line-view.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  18.4 KB  |  521 lines  |  [TEXT/CCL2]
  1. ;;; number-line-view.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; This file provides a new type of dialog item.  The item is a
  12. ;;; number line that can be dragged or rescaled by the user in real time.
  13. ;;;
  14. ;;; USE:
  15. ;;;
  16. ;;; number-line-vertical-view   -  dialog item class for vertical scales
  17. ;;; number-line-horizontal-view -  dialog item class for horizontal scales
  18. ;;;    :title          - title of the number line
  19. ;;;    :scroll-p       - allow scrolling?
  20. ;;;    :rescale-p      - allow rescaling?
  21. ;;;    :dialog-item-action  - fn called after scroll or rescale by the user,
  22. ;;;                           takes the dialog item as an argument
  23. ;;;    :start             - initial start value of the number line
  24. ;;;    :end               - initial end value of the number line
  25. ;;;    :min-value         - minimum start value
  26. ;;;    :max-value         - maximum end value
  27. ;;;    :rescale-cursor    - cursor to use during rescale
  28. ;;;    :scroll-cursor     - cursor to use during scroll
  29. ;;;    :tick-mark-inc-fn  - fn to determine the increment for tick marks.
  30. ;;;                         takes the drawing scale as an arg
  31. ;;;    :string-trans-fn   - fn to transform a number line value (number)
  32. ;;;                         into a string (any string...)
  33. ;;;    :title-font-spec   - font of the title
  34. ;;;    :mark-font-spec    - font of the tick marks on the number line
  35. ;;;    :number-line-width - width of the number line
  36. ;;;
  37. ;;; set-number-line-range  - set start and end of the number line
  38. ;;; number-line-start      - access start
  39. ;;; number-line-end        - access end
  40. ;;;
  41. ;;;
  42. ;;; HISTORY:
  43. ;;;
  44. ;;; 7/20/92 Removed remaining QD dependencies.  - PM
  45. ;;; 7/13/92 Fixed rescale cursor bug.  - PM
  46. ;;; 6/29/92 Added GWorld offscreen graphics smoothing.  - PM
  47. ;;; 4/10/92 Created.  - PM
  48. ;;;
  49.  
  50. (in-package :ccl)
  51.  
  52. (eval-when (:compile-toplevel :load-toplevel :execute)
  53.   (export '(number-line-horizontal-view number-line-vertical-view
  54.             set-number-line-range number-line-start number-line-end)
  55.           :ccl))
  56.  
  57. (require :GWorld-view-extensions)
  58. (require :graphics-tools)
  59.  
  60.  
  61. (defclass number-line-view (dialog-item)
  62.   ((title :accessor title :initarg :title)
  63.    
  64.    (scroll-p :accessor scroll-p :initarg :scroll-p)
  65.    (rescale-p :accessor rescale-p :initarg :rescale-p)
  66.    
  67.    (scale :accessor number-line-scale)
  68.    
  69.    (number-line-rect :accessor number-line-rect)
  70.    
  71.    (start-value :initarg :start :accessor start-value)
  72.    (end-value :initarg :end :accessor end-value)
  73.    (min-value :initarg :min-value :accessor min-value)
  74.    (max-value :initarg :max-value :accessor max-value)
  75.    
  76.    (number-line-width :initarg :number-line-width :accessor number-line-width)
  77.    
  78.    (tick-mark-inc-fn :initarg :tick-mark-inc-fn :accessor tick-mark-inc-fn)
  79.    (string-trans-fn :initarg :string-trans-fn :accessor string-trans-fn)
  80.    
  81.    (rescale-cursor :initarg :rescale-cursor :accessor rescale-cursor)
  82.    (scroll-cursor :initarg :scroll-cursor :accessor scroll-cursor)
  83.    
  84.    (mark-font :initarg :mark-font-spec :accessor mark-font)
  85.    (mark-ff :initarg :mark-ff :accessor mark-ff)
  86.    (mark-ms :initarg :mark-ms :accessor mark-ms)
  87.    
  88.    (title-font :initarg :title-font-spec :accessor title-font)
  89.    (title-ff :initarg :title-ff :accessor title-ff)
  90.    (title-ms :initarg :title-ms :accessor title-ms)
  91.    
  92.    (color-list :initarg :color-list :accessor color-list))
  93.   (:default-initargs 
  94.     :title '("Untitled")
  95.     :view-position #@(0 0)
  96.     :scroll-p t
  97.     :rescale-p t
  98.     :start 0
  99.     :end 10
  100.     :min-value 0
  101.     :max-value 10
  102.     :rescale-cursor *arrow-cursor*
  103.     :scroll-cursor *arrow-cursor*
  104.     :string-trans-fn #'princ-to-string
  105.     :title-font-spec '("times" 14)
  106.     :mark-font-spec '("times" 10)
  107.     :color-list ()
  108.     :number-line-width 15))
  109.  
  110.  
  111. (defclass number-line-vertical-view (number-line-view)
  112.   ()
  113.   (:default-initargs 
  114.     :view-size #@(30 100) 
  115.     :tick-mark-inc-fn #'(lambda (scale) (find-pixel-increment-v scale 1/4 1))) )
  116.  
  117.  
  118. (defclass number-line-horizontal-view (number-line-view)
  119.   ()
  120.   (:default-initargs 
  121.     :view-size #@(100 30)
  122.     :tick-mark-inc-fn #'(lambda (scale) (find-pixel-increment-h scale 1/4 1))) )
  123.  
  124.  
  125. (defmethod initialize-instance ((view number-line-view) &rest initargs)
  126.   (declare (ignore initargs))
  127.   (call-next-method)
  128.   (setf (number-line-rect view) (make-record :rect))
  129.   (set-number-line-fonts view (title-font view) (mark-font view))
  130.   (set-view-size view (view-size view)) )
  131.  
  132.  
  133. (defmethod remove-view-from-window ((view number-line-view))
  134.   (dispose-record (number-line-rect view) :rect)
  135.   (call-next-method))
  136.   
  137.  
  138. (defmethod set-number-line-fonts ((view number-line-view) title-font mark-font)
  139.   (multiple-value-bind (ff ms) (font-codes title-font)
  140.     (setf (title-ff view) ff)
  141.     (setf (title-ms view) ms))
  142.   (multiple-value-bind (ff ms) (font-codes mark-font)
  143.     (setf (mark-ff view) ff)
  144.     (setf (mark-ms view) ms)))
  145.  
  146.  
  147.  
  148. ;;;;
  149. ;;;; RESIZING
  150. ;;;;
  151.  
  152. (defmethod set-view-size ((view number-line-view) h &optional v)
  153.   (declare (ignore h v))
  154.   (invalidate-view view t)
  155.   (call-next-method)
  156.   (set-number-line-size view) )
  157.  
  158.  
  159. (defmethod set-number-line-scale ((view number-line-view))
  160.   (let ((delta (- (end-value view) (start-value view))))
  161.     (if (plusp delta)
  162.       (setf (number-line-scale view) (/ (number-line-length view) delta))) ))
  163.  
  164.  
  165. ;;;
  166. ;;; Horizontal
  167. ;;;
  168.  
  169. (defmethod number-line-length ((view number-line-horizontal-view))
  170.   (point-h (view-size view)))
  171.  
  172.  
  173. (defmethod set-number-line-size ((view number-line-horizontal-view))
  174.   (rset (number-line-rect view) rect.top 0)
  175.   (rset (number-line-rect view) rect.left 0)
  176.   (rset (number-line-rect view) rect.bottom 
  177.         (+ (number-line-width view) (line-height (mark-font view))))
  178.   (rset (number-line-rect view) rect.right (point-h (view-size view)))
  179.   (set-number-line-scale view))
  180.  
  181.  
  182. ;;;
  183. ;;; Vertical
  184. ;;;
  185.  
  186. (defmethod number-line-length ((view number-line-vertical-view))
  187.   (point-v (view-size view)))
  188.  
  189.  
  190. (defmethod set-number-line-size ((view number-line-vertical-view))
  191.   (rset (number-line-rect view) rect.top 0)
  192.   (rset (number-line-rect view) rect.left 
  193.         (- (point-h (view-size view)) 
  194.            (number-line-width view)
  195.            (max (string-width (princ-to-string (* 10 (end-value view))) (mark-font view))
  196.                 (string-width (princ-to-string (* 10 (start-value view))) (mark-font view)))))
  197.   (rset (number-line-rect view) rect.bottomright (view-size view))
  198.   (set-number-line-scale view))
  199.  
  200.  
  201.  
  202. ;;;;
  203. ;;;; DRAWING
  204. ;;;;
  205.  
  206. (defmethod view-draw-contents ((view number-line-view))
  207.   (call-next-method)
  208.   (with-focused-view view
  209.     (with-fore-color (part-color view :title)
  210.       (with-font-codes (title-ff view) (title-ms view)
  211.         (draw-line-title view)))
  212.     (draw-number-line view) ))
  213.  
  214.  
  215. (defmethod draw-number-line ((view number-line-view))
  216.   (let ((left (rref (number-line-rect view) rect.left))
  217.         (top (rref (number-line-rect view) rect.top))
  218.         (right (rref (number-line-rect view) rect.right))
  219.         (bottom (rref (number-line-rect view) rect.bottom)))
  220.     
  221.     (with-GWorld-no-colorization (view left top right bottom)
  222.       (with-fore-color (part-color view :frame)
  223.         (draw-number-bar view)
  224.         (draw-number-line-tick-marks view))
  225.       (with-fore-color (part-color view :numbers)
  226.         (with-font-codes (mark-ff view) (mark-ms view)
  227.           (draw-number-line-numbers view))) )))
  228.  
  229.  
  230. ;;;
  231. ;;; Horizontal
  232. ;;;
  233.  
  234. (defmethod draw-line-title ((view number-line-horizontal-view))
  235.   (do* ((i 0 (1+ i))
  236.         (center (round (point-h (view-size view)) 2))
  237.         (title (title view))
  238.         (separation (line-height (title-font view)))
  239.         (start-v (round (+ (number-line-width view)
  240.                            (* 2 (line-height (mark-font view))))))
  241.         (rest-text title (rest rest-text))
  242.         (text (first rest-text) (first rest-text))
  243.         (width (if text (string-width text)) (if text (string-width text))) )
  244.        ((null text))
  245.     (#_MoveTo :long (make-point (- center (round width 2)) (+ start-v (* i separation))))
  246.     (with-pstrs ((di-title text))
  247.       (#_DrawString :ptr di-title)) ))
  248.  
  249.  
  250. (defmethod draw-number-bar ((view number-line-horizontal-view))
  251.   (let* ((bottom (number-line-width view))
  252.          (right (- (point-h (view-size view)) 2))
  253.          (middle (round bottom 2))
  254.          (old-pn (pref (wptr *GW-offscreen-view*) windowRecord.pnsize)))
  255.     (with-port (wptr *GW-offscreen-view*) (#_PenSize :long #@(2 2)))
  256.     (#_MoveTo :long (make-GW-point #@(0 0)))
  257.     (#_LineTo :long (make-GW-point 0 bottom))
  258.     (#_MoveTo :long (make-GW-point right 0))
  259.     (#_LineTo :long (make-GW-point right bottom))
  260.     (#_MoveTo :long (make-GW-point 0 middle))
  261.     (#_LineTo :long (make-GW-point right middle))
  262.     (with-port (wptr *GW-offscreen-view*) (#_PenSize :long old-pn))) )
  263.  
  264.  
  265. (defmethod draw-number-line-tick-marks ((view number-line-horizontal-view))
  266.   (do* ((increment (funcall (tick-mark-inc-fn view) (number-line-scale view)))
  267.         (current-mark (* (ceiling (start-value view) increment) increment)
  268.                       (+ current-mark increment))
  269.         (start 0)
  270.         (end (number-line-width view))
  271.         (end-value (end-value view))
  272.         (mark-position (line-number-position view current-mark)
  273.                        (line-number-position view current-mark)))
  274.        ((> current-mark end-value))   
  275.     (#_MoveTo :long (make-GW-point mark-position start))
  276.     (#_LineTo :long (make-GW-point mark-position end)) ))
  277.  
  278.  
  279. (defmethod draw-number-line-numbers ((view number-line-horizontal-view))
  280.   (do* ((string-fn (string-trans-fn view))
  281.         (end (+ (number-line-width view) (line-height (mark-font view))))
  282.         (size (point-h (view-size view)))
  283.         (increment (funcall (tick-mark-inc-fn view) (number-line-scale view)))
  284.         (current-mark (* (ceiling (start-value view) increment) increment)
  285.                       (+ current-mark increment))
  286.         (mark-string (funcall string-fn current-mark)
  287.                      (funcall string-fn current-mark))
  288.         (width (string-width mark-string) 
  289.                (string-width mark-string))
  290.         (mark-position (line-number-position view current-mark)
  291.                        (line-number-position view current-mark)))
  292.        ((> current-mark (end-value view)))
  293.     
  294.     (#_MoveTo :long (make-GW-point (value-in-range 0 (- mark-position (round width 2)) (- size width))
  295.                                    end))
  296.     (with-pstrs ((di-title mark-string))
  297.       (#_DrawString :ptr di-title)) ))
  298.  
  299.  
  300. ;;;
  301. ;;; Vertical
  302. ;;;
  303.  
  304. (defmethod draw-line-title ((view number-line-vertical-view))
  305.   (do* ((i 0 (1+ i))
  306.         (center (round (- (point-h (view-size view)) (* 1.9 (number-line-width view))) 2))
  307.         (title (title view))
  308.         (separation (- (line-height (title-font view)) 2))
  309.         (start-v (max separation 
  310.                       (- (round (point-v (view-size view)) 2)
  311.                          (round (* (length title) separation) 2))))
  312.         (rest-text title (rest rest-text))
  313.         (text (first rest-text) (first rest-text))
  314.         (width (if text (string-width text)) (if text (string-width text))) )
  315.        ((null text))
  316.     (#_MoveTo :long (make-point (- center (round width 2)) 
  317.                                 (+ start-v (* i separation))))
  318.     (with-pstrs ((di-title text))
  319.       (#_DrawString :ptr di-title)) ))
  320.  
  321.  
  322. (defmethod draw-number-bar ((view number-line-vertical-view))
  323.   (let* ((bottom (- (point-v (view-size view)) 2))
  324.          (left (- (point-h (view-size view)) (number-line-width view)))
  325.          (right (+ left (number-line-width view)))
  326.          (middle (+ (round (number-line-width view) 2) left))
  327.          (old-pn (pref (wptr *GW-offscreen-view*) windowRecord.pnsize)))
  328.     (with-port (wptr *GW-offscreen-view*) (#_PenSize :long #@(2 2)))
  329.     (#_MoveTo :long (make-GW-point left 0))
  330.     (#_LineTo :long (make-GW-point right 0))
  331.     (#_MoveTo :long (make-GW-point left bottom))
  332.     (#_LineTo :long (make-GW-point right bottom))
  333.     (#_MoveTo :long (make-GW-point middle 0))
  334.     (#_LineTo :long (make-GW-point middle bottom))
  335.     (with-port (wptr *GW-offscreen-view*) (#_PenSize :long old-pn)) ))
  336.  
  337.  
  338. (defmethod draw-number-line-tick-marks ((view number-line-vertical-view))
  339.   (do* ((increment (funcall (tick-mark-inc-fn view) (number-line-scale view)))
  340.         (current-mark (* (ceiling (start-value view) increment) increment)
  341.                       (+ current-mark increment))
  342.         (end-value (end-value view))
  343.         (start (- (point-h (view-size view)) (number-line-width view)))
  344.         (end (+ start (number-line-width view)))
  345.         (mark-position (line-number-position view current-mark)
  346.                        (line-number-position view current-mark)))
  347.        ((> current-mark end-value))
  348.     (#_MoveTo :long (make-GW-point start mark-position))
  349.     (#_LineTo :long (make-GW-point end mark-position)) ))
  350.  
  351.  
  352. (defmethod draw-number-line-numbers ((view number-line-vertical-view))
  353.   (do* ((vertical-mark-correction (round (line-height (mark-font view)) 3))
  354.         (increment (funcall (tick-mark-inc-fn view) (number-line-scale view)))
  355.         (end-value (end-value view))
  356.         (string-fn (string-trans-fn view))
  357.         (start (- (point-h (view-size view)) (number-line-width view)))
  358.         (min-y-pos (- (line-height (mark-font view)) 3))
  359.         (max-y-pos (point-v (view-size view)))
  360.         (current-mark (* (ceiling (start-value view) increment) increment)
  361.                       (+ current-mark increment))
  362.         (mark-string (funcall string-fn current-mark)
  363.                      (funcall string-fn current-mark))
  364.         (width (string-width mark-string) 
  365.                (string-width mark-string))
  366.         (mark-position (line-number-position view current-mark)
  367.                        (line-number-position view current-mark)))
  368.        ((> current-mark end-value))  
  369.     
  370.     (#_MoveTo :long (make-GW-point (- start width)
  371.                                    (value-in-range min-y-pos (+ mark-position vertical-mark-correction) max-y-pos)))
  372.     (with-pstrs ((di-title mark-string))
  373.       (#_DrawString :ptr di-title)) ))
  374.  
  375.  
  376.  
  377. ;;;;
  378. ;;;; USER MANIPULATION
  379. ;;;;
  380.  
  381. (defmethod view-click-event-handler ((view number-line-view) where)
  382.   (declare (ignore where))
  383.  
  384.   (when (point-in-rect-p (number-line-rect view) (view-mouse-position view))
  385.     (let ((end (end-value view))
  386.           (scale (number-line-scale view)))
  387.       (cond ((and (rescale-p view) (shift-key-p)) (user-drag-end-value view))
  388.             ((scroll-p view) (user-scroll-range view)))
  389.       (when (or (= scale (number-line-scale view)) (/= end (end-value view)))
  390.              (dialog-item-action view)) )))
  391.  
  392.  
  393. (defmethod user-drag-end-value ((view number-line-view))
  394.   (declare (inline draw-number-line set-number-line-scale line-position-length))
  395.   (do* ((length (number-line-length view))
  396.         (start (start-value view))
  397.         (min (min-value view))
  398.         (max (max-value view))
  399.         (old-click-value (line-position-length view (view-mouse-position view)))
  400.         (mouse-position (max (line-point-value view (view-mouse-position view)) 1)
  401.                         (max (line-point-value view (view-mouse-position view)) 1))
  402.         (old-end-value (end-value view) end-value)
  403.         (end-value (value-in-range min (+ (round (* length old-click-value) mouse-position) start) max)
  404.                    (value-in-range min (+ (round (* length old-click-value) mouse-position) start) max)))
  405.        ((not (mouse-down-p)))
  406.     (when (/= end-value old-end-value)
  407.       (setf (end-value view) end-value)
  408.       (set-number-line-scale view)
  409.       (draw-number-line view))))
  410.  
  411.  
  412. (defmethod user-scroll-range ((view number-line-view))
  413.   (declare (inline draw-number-line set-number-line-scale line-position-length))
  414.   (do* ((old-click-value (line-position-length view (view-mouse-position view)))
  415.         (original-start (start-value view))
  416.         (original-end (end-value view))
  417.         (range (- original-end original-start))
  418.         (min (min-value view))
  419.         (max (max-value view))
  420.         (mouse-position (view-mouse-position view)
  421.                         (view-mouse-position view))
  422.         (new-value (line-position-length view mouse-position)
  423.                    (line-position-length view mouse-position))
  424.         (delta (- old-click-value new-value) 
  425.                (- old-click-value new-value))
  426.         (old-start-value (start-value view) start-value)
  427.         (start-value (value-in-range min (+ original-start delta) (- max range))
  428.                      (value-in-range min (+ original-start delta) (- max range))))
  429.        ((not (mouse-down-p)))
  430.     (when (/= start-value old-start-value)
  431.       (setf (start-value view) start-value)
  432.       (setf (end-value view) (+ start-value range))
  433.       (draw-number-line view))))
  434.  
  435.  
  436. ;;;;
  437. ;;;; UNIT TRANSLATION
  438. ;;;;
  439.  
  440. ;;;
  441. ;;; Horizontal
  442. ;;;
  443.  
  444. (defmethod line-number-position ((view number-line-horizontal-view) number)
  445.   (round (* (- number (start-value view)) (number-line-scale view))))
  446.  
  447.  
  448. (defmethod line-position-length ((view number-line-horizontal-view) point)
  449.   (round (point-h point) (number-line-scale view)))
  450.  
  451.  
  452. (defmethod line-position-number ((view number-line-horizontal-view) position)
  453.   (declare (inline line-position-length))
  454.   (+ (start-value view) (line-position-length view position)))
  455.  
  456.  
  457. (defmethod line-point-value ((view number-line-horizontal-view) point)
  458.   (point-h point))
  459.  
  460.  
  461.  
  462. ;;;
  463. ;;; Vertical
  464. ;;;
  465.  
  466. (defmethod line-number-position ((view number-line-vertical-view) number)
  467.   (round (- (point-v (view-size view))
  468.             (* (- number (start-value view)) (number-line-scale view)))) )
  469.  
  470.  
  471. (defmethod line-position-length ((view number-line-vertical-view) point)
  472.   (round (- (point-v (view-size view)) (point-v point)) (number-line-scale view)))
  473.  
  474.  
  475. (defmethod line-position-number ((view number-line-vertical-view) position)
  476.   (declare (inline line-position-length))
  477.   (+ (start-value view) (line-position-length view position)))
  478.  
  479.  
  480. (defmethod line-point-value ((view number-line-vertical-view) point)
  481.   (declare (inline number-line-length))
  482.   (- (number-line-length view) (point-v point)))
  483.  
  484.  
  485.  
  486. ;;;;
  487. ;;;; CURSOR
  488. ;;;;
  489.  
  490. (defmethod view-cursor ((view number-line-view) point)
  491.   (if (point-in-rect-p (number-line-rect view) point)
  492.     (cond ((and (shift-key-p) (rescale-p view)) (rescale-cursor view))
  493.           ((scroll-p view) (scroll-cursor view))
  494.           (t *arrow-cursor*))
  495.     (call-next-method)))
  496.  
  497.  
  498.  
  499. ;;;;
  500. ;;;; USER FUNCTIONS
  501. ;;;;
  502.  
  503. (defmethod number-line-start ((view number-line-view))
  504.   (start-value view))
  505.  
  506.  
  507. (defmethod number-line-end ((view number-line-view))
  508.   (end-value view))
  509.  
  510.  
  511. (defmethod set-number-line-range ((view number-line-view) start end)
  512.   (setf (start-value view) start)
  513.   (setf (end-value view) end)
  514.   (set-number-line-scale view))
  515.  
  516.  
  517.  
  518. (provide :number-line-view)
  519.  
  520.  
  521.